home *** CD-ROM | disk | FTP | other *** search
/ PsL Monthly 1993 December / PSL Monthly Shareware CD-ROM (December 1993).iso / prgmming / dos / pascal / lzsfx.com / LZSFX.PAS < prev    next >
Encoding:
Pascal/Delphi Source File  |  1989-02-02  |  3.7 KB  |  125 lines
  1. program LZSFX;
  2. (* ---------------
  3. #  LZSS self extract by MASSAN
  4.  
  5.  $Log: RCS/lzsfx.pas $
  6.   revision 1.4 MAS 89/02/02 03:46:31
  7.   bug fixed. (calc page size)
  8.   
  9. # revision 1.3 MAS 88/07/10 21:48:55
  10. # not directly change code segment.
  11. # 
  12. # revision 1.2 MAS 88/06/18 22:04:00
  13. # change to make .EXE file.
  14. # arg 2 = destin file.
  15. # 
  16. # revision 1.1 MAS 88/05/22 20:08:48
  17. # Initial revision
  18. # 
  19.    -----------------*)
  20. const
  21.   _header: string[80] = '$Header: RCS/lzsfx.pas 1.4 89/02/02 03:46:31 MAS Exp $';
  22.   pathlen = 64 ;  { MS-DOS}
  23.   maxstr = 255 ;
  24.   texbufsize = 1024;
  25. type
  26.   tex    = text;
  27.   anystr = string;
  28.   pathtype = string[pathlen];
  29. {$i open.prc}
  30. const
  31.     bufsize = 4096;
  32. var f,ouf: file;
  33.     fname,oufname: pathtype;
  34.     size : integer;
  35.     buf : array[1..bufsize] of byte;
  36.  
  37. procedure LZStub; external;
  38. {$L LZSTUB.BOB}
  39. procedure LZStubJr; external;   (* small size version *)
  40. {$L LZSTUBJR.BOB}
  41.  
  42.  
  43. procedure WriteHeader;
  44.   const headmin   = 32;           (* minimum size of header *)
  45.   type exehead= record case Boolean of
  46.     true:(
  47.         id : array[1..2] of char; (* MZ *)
  48.         lastbyte, page,           (* module size = (page-1)*512+lastbyte*)
  49.                                   (* cf. GetExeLen *)
  50.         relnum,                   (* # of relocation table *)
  51.         headsize,                 (* size of header *)
  52.         minalloc, maxalloc,       (* free area size *)
  53.         ss, sp,                   (* initial value of stack *)
  54.         checksum,                 (* ignore it *)
  55.         ip, cs,                   (* initial value of pc    *)
  56.         relofs, overlaynum        (* ignore it *)
  57.         : word);
  58.     false:(a: array[0..513] of byte);
  59.       end ;
  60.  
  61.   procedure GetExeLen(var h:exehead; var exestart,exelen:integer);
  62.     begin
  63.       with h do begin
  64.         exestart := headsize shl 4;
  65.         if lastbyte = 0 then exelen := page shl 9 - exestart
  66.                         else exelen := (page-1) shl 9 +lastbyte-exestart
  67.       end
  68.     end ;
  69.   
  70.     var exeptr,exenew: ^exehead;
  71.       exestart,exelen: integer;
  72.       modulesize: longint;
  73.   begin
  74.     exeptr := Addr(LZStubJr);
  75.     GetExeLen(exeptr^, exestart,exelen);
  76.     modulesize := FileSize(f) + exelen + 1;     (* 1 for end mark *)
  77.     if modulesize >= $ffff then begin
  78.       exeptr := Addr(LZStub);
  79.       GetExeLen(exeptr^, exestart, exelen);
  80.       modulesize := FileSize(f) + exelen + 1
  81.     end;
  82.     GetMem(exenew, exelen+headmin);
  83. (* ╤└▐┼ reloc.ª ╩╠▐▓├ ║╦▀░ *)
  84.     Move(exeptr^, exenew^, headmin);
  85.     Move(exeptr^.a[exestart], exenew^.a[headmin], exelen);
  86.  
  87.     with exenew^ do begin
  88.       headsize := headmin shr 4 ;
  89.       page     := (modulesize + headmin) shr 9 + 1;
  90.       lastbyte := (modulesize + headmin) and 511;
  91.       ss       := (modulesize + 15) shr 4
  92.     end;
  93.     BlockWrite(ouf, exenew^, exelen+headmin);
  94.     FreeMem(exenew, exelen+headmin)
  95.   end;
  96.  
  97.  
  98. begin
  99.   if ParamCount < 1 then begin
  100.     WriteLn('usage: LZSFX source[.LZS] [destin[.EXE]]'); Halt(1)
  101.   end;
  102. {$i-}
  103.   fname := NewFname(ParamStr(1),'LZS','+');
  104.   Assign(f, fname);  Reset(f, 1);  if IOresult <> 0 then CantHalt(fname);
  105.  
  106.   if ParamCount > 1 then oufname := NewFname(ParamStr(2),'EXE','-')
  107.                     else oufname := NewFname(fname,'EXE','-');
  108.  
  109.   if FileExist(oufname) then begin
  110.     WriteLn('File ', oufname, ' already exists'); Halt(1)
  111.   end;
  112.   Assign(ouf, oufname); Rewrite(ouf, 1); if IOresult <> 0 then CantHalt(fname);
  113. {$i+}
  114.   Write('Creating SFX file ', oufname);
  115.  
  116.   WriteHeader;
  117.   while not Eof(f) do begin
  118.     BlockRead(f, buf, SizeOf(buf), size);
  119.     BlockWrite(ouf, buf, size)
  120.   end;
  121.   buf[1] := 0; BlockWrite(ouf, buf[1], 1);    (* end mark *)
  122.   Close(f); Close(ouf);
  123.   WriteLn
  124. end.
  125.